home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / tttsrc51.zip / READTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  37KB  |  1,129 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.10                              }
  5. {                                (Europe)                                  }
  6. {                                                                          }
  7. {               Copyright 1986-1993 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}
  13.                      {       Unit:  ReadTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {History:         2/24/89   5.00a  Reversed return codes in ReadLine
  18.                   3/05/89   5.00b  Added Box proc to Read_Real
  19.                             5.01a  Added DEBUG compiler directive and added
  20.                                    mouse Enter/Esc support
  21.                  01/04/93   5.10   DPMI compatible version
  22. }
  23.  
  24. {$S-,R-,V-}
  25. {$IFNDEF DEBUG}
  26. {$D-}
  27. {$ENDIF}       
  28.  
  29. Unit ReadTTT5;
  30.  
  31. Interface
  32.  
  33. Uses CRT,FastTTT5,WinTTT5,StrnTTT5,KeyTTT5;
  34.  
  35. Type
  36.    R_Display = record
  37.                     WhiteSpace  : char;        {used to pad input field - default ··········} 
  38.                     AllowEsc    : boolean;     {allow the he user to escape?} 
  39.                     Beep        : Boolean;     {allow the old proverbial beep} 
  40.                     Insert      : boolean;     {initially in insert mode?} 
  41.                     BegCursor   : boolean;     {place cursor at beginning of line} 
  42.                     AllowNull   : boolean;     {allow user to input a '' or null value} 
  43.                     RightJustify: Boolean;     {right justify string on termination} 
  44.                     EraseDefault: Boolean;     {clear entry of alphanumeric pressed} 
  45.                     SuppressZero: Boolean;     {have empty field is value = zero}
  46.                     FCol        : byte;        {normal foreground color of input field}
  47.                     BCol        : byte;        {normal background of input field}
  48.                     HiFCol      : byte;        {highlighted fgnd color for Read_Select}
  49.                     HiBCol      : byte;        {highlighted bgnd color for Read_Select}
  50.                     LoFCol      : byte;        {normal fgnd color for Read_Select}
  51.                     LoBCol      : byte;        {normal bgnd color for Read_Select}
  52.                     PFcol       : byte;        {prompt foreground color}
  53.                     PBCol       : byte;        {prompt background color}
  54.                     BoxFCol     : byte;        {box foreground color}
  55.                     BoxBCol     : byte;        {Box background color}
  56.                     Msg_FCol    : byte;        {Foreground color for error messages}
  57.                     Msg_BCol    : byte;        {Background color for error messages}
  58.                     Msg_Line    : byte;        {line for error messages}
  59.                     End_chars   : set of char; {end of input chars}
  60.                     RealDP      : byte;        {no of decimal places on real}
  61.                end;
  62.  
  63. const
  64.     NoPrompt:string[1] = '';
  65. Var
  66.   RTTT : R_Display;
  67.   R_Char : char;
  68.   R_Null : boolean;
  69.  
  70. Procedure Default_Settings;
  71. Procedure ReadLine(X,Y,L,F,B:byte;var Text: string;var Retcode:integer);
  72. Procedure Read_String(X,Y,L:byte;
  73.                       Prompt:StrScreen; 
  74.                       BoxType: byte;
  75.                       Var Txt:StrScreen);
  76. Procedure Read_String_Upper(X,Y,L:byte;
  77.                             Prompt:StrScreen;
  78.                             BoxType: byte;
  79.                             Var Txt:StrScreen);
  80. Procedure Read_Password(X,Y,L:byte;
  81.                         Prompt:StrScreen;
  82.                         BoxType: byte;
  83.                         Var Txt:StrScreen);
  84. Procedure Read_Alpha(X,Y,L:byte;
  85.                      Prompt:StrScreen;
  86.                      BoxType: byte;
  87.                      Var Txt:StrScreen);
  88. Procedure Read_YN(X,Y:byte;
  89.                   Prompt:StrScreen;
  90.                   BoxType: byte;
  91.                   Var Yes:Boolean);
  92. Procedure Read_Byte(X,Y,L:byte; 
  93.                     Prompt:StrScreen;
  94.                     BoxType: byte;
  95.                     Var B : Byte;
  96.                     Min, Max : Byte);
  97. Procedure Read_Word(X,Y,L:byte; 
  98.                     Prompt:StrScreen;
  99.                     BoxType: byte;
  100.                     Var W : word;
  101.                     Min, Max : word);
  102. Procedure Read_Int(X,Y,L:byte;
  103.                    Prompt:StrScreen;
  104.                    BoxType: byte;
  105.                    Var W : integer;
  106.                    Min, Max : integer);
  107. Procedure Read_LongInt(X,Y,L:byte;
  108.                        Prompt:StrScreen;
  109.                        BoxType: byte;
  110.                        Var W : longint;
  111.                        Min, Max : longint);
  112. Procedure Read_Real(X,Y,L:byte;
  113.                     Prompt:StrScreen;
  114.                     BoxType: byte;
  115.                     Var W : real;
  116.                     Min, Max : real);
  117. Procedure Read_Select(X,Y:byte;Pmt,Txt:StrScreen;var Choice:byte);
  118. Implementation
  119.  
  120. CONST
  121.     PassChar    = #15;
  122.     CursorRight = #205;
  123.     CursorLeft  = #203;
  124.     CursorDown  = #208;
  125.     CursorUp    = #200;
  126.     EnterKey    = #13;
  127.     EscKey      = #27;
  128.     EndKey      = #207;
  129.     HomeKey     = #199;
  130.     DelKey      = #211;
  131.     Backspace   = #8;
  132.     InsKey      = #210;
  133.     Zap         = #160;      {Alt D to delete the field}
  134.     MinInt              = -32768;
  135.     MaxLongInt:longint  =  2147483647;
  136.     MinLongInt:longint  = -2147483647;
  137.     MaxWord             =  65535;
  138.     MinWord             =  0;
  139.     
  140. VAR
  141.    Cursor_X,
  142.    Cursor_Y,
  143.    ScanTop,
  144.    ScanBot   : byte;
  145.  
  146. Procedure Default_Settings;
  147. begin
  148.    with RTTT do
  149.    begin
  150.        WhiteSpace   := #250;
  151.        Beep         := true;
  152.        BegCursor    := false;
  153.        Insert       := false;
  154.        AllowEsc     := true;
  155.        AllowNull    := true;
  156.        RightJustify := false;
  157.        EraseDefault := false;
  158.        SuppressZero := true;
  159.        End_Chars := [#13,#133];  {Enter}
  160.        RealDP := 2;  
  161.        If not ColorScreen then
  162.        begin
  163.            FCol := black;
  164.            BCol := lightgray;
  165.            HiFCol := white;
  166.            HiBCol := black;
  167.            LoFCol := lightgray;
  168.            LoBCol := black;
  169.            PFCol := white;
  170.            PBCol := black;
  171.            BoxFCol := white;
  172.            BoxBCol := black;
  173.            Msg_FCol := white;
  174.            Msg_BCol := black;
  175.            Msg_Line := 0;
  176.        end
  177.        else
  178.        begin
  179.            FCol := black;
  180.            BCol := lightgray;
  181.            HiFCol := black;
  182.            HiBCol := lightgray;
  183.            LoFCol := lightgray;
  184.            LoBCol := black;
  185.            PFCol := white;
  186.            PBCol := black;
  187.            BoxFCol := white;
  188.            BoxBCol := black;
  189.            Msg_FCol := lightred;
  190.            Msg_BCol := black;
  191.            Msg_Line := 0;
  192.        end;
  193.    end;
  194. end;
  195.  
  196. Procedure Clang;
  197. begin
  198.     If RTTT.Beep then
  199.     begin
  200.         sound(500);
  201.         delay(50);
  202.         nosound;
  203.     end;
  204. end;
  205.  
  206. Procedure Read_Line(X,Y,L,F,B,Format:byte;
  207.                      var Text   :string);
  208. {
  209. X is X coord of first character in field
  210. Y is Y coord of field
  211. L is the maximum length of the input field
  212. F is the foreground color
  213. B is the background color
  214. Fornat Codes:      1   Any String
  215.                    2   Force Upper String
  216.                    3   Yes/No
  217.                    4   Alphabetics only
  218.                    5   Integer
  219.                    6   LongInteger
  220.                    7   Real
  221.                    8   Word
  222.                    (*   Maybe
  223.                    9   Date    (MM/DD/YY)
  224.                    10  Date    (DD/MM/YY)
  225.                    *)
  226.                    11  Echo a Password
  227. Text is a string updated with the string equivalent of user input
  228. }
  229. var
  230.     TempText : string;
  231.     CursorPos : byte;
  232.     InsertMode,
  233.     Password,
  234.     Alldone : boolean;
  235.     FirstCharPress: boolean;
  236.     Ch : char;
  237.  
  238.     Procedure Check_Parameters;
  239.     begin
  240.         TempText := Text;
  241.         If length(TempText) > L then
  242.            Delete(Temptext,L+1,length(TempText)-L);
  243.         If not X in [1..80] then
  244.            X := 1;
  245.         If X + L - 1 > 80 then X := 81 - L;
  246.         If not Y in [1..25] then
  247.            Y := 1;
  248.         If RTTT.BegCursor then
  249.            CursorPos := 1
  250.         else
  251.         begin
  252.             If length(TempText) < L then
  253.                CursorPos := length(TempText) + 1
  254.             else
  255.                CursorPos := length(TempText);
  256.         end;
  257.         InsertMode  := RTTT.Insert;
  258.         Alldone := False;
  259.         If Format = 11 then
  260.         begin
  261.             Password := true;
  262.             Format := 1;
  263.         end
  264.         else
  265.            Password := false;
  266.     end;  {sub Proc Check_Parameters}
  267.  
  268.     Function FillWhiteSpace(Str:string):string;
  269.     var I : integer;
  270.     begin
  271.         If Password then
  272.            Str := replicate(length(Str),PassChar);
  273.         while length(Str) < L do
  274.               Str := Str + RTTT.WhiteSpace;
  275.         FillWhiteSpace := Str;
  276.     end; {sub Func FillWhiteSpace}
  277.  
  278.     Procedure MoveTheCursor;
  279.     begin
  280.         GotoXY(X+CursorPos-1,Y);
  281.     end;  {sub Proc MoveTheCursor}
  282.  
  283.     Procedure Write_String;
  284.     begin
  285.         Fastwrite(X,Y,attr(F,B),FillWhiteSpace(TempText));
  286.         MoveTheCursor;
  287.     end;
  288.  
  289.     Procedure Erase_Field;
  290.     begin
  291.         TempText := '';
  292.         CursorPos := 1;
  293.         Write_String;
  294.     end;
  295.  
  296.     Procedure Char_Backspace;
  297.     begin
  298.         If CursorPos > 1 then
  299.         begin
  300.             CursorPos := Pred(CursorPos);
  301.             Delete(TempText,CursorPos,1);
  302.             Write_String;
  303.        end;
  304.     end;   {sub Proc Char_Backspace}
  305.  
  306.     Procedure Char_Del;
  307.     begin
  308.         If CursorPos <= length(TempText) then
  309.         begin
  310.             Delete(TempText,CursorPos,1);
  311.             Write_String;
  312.         end;
  313.     end;   {sub Proc Char_Del}
  314.  
  315.     Procedure Add_Char(Ch:char);
  316.     begin
  317.         If InsertMode then
  318.         begin
  319.             If length(TempText) < L then
  320.             begin
  321.                 Insert(Ch,TempText,CursorPos);
  322.                 If CursorPos < L then
  323.                    CursorPos := Succ(CursorPos);
  324.            end;
  325.         end
  326.         else {not insertmode}
  327.         begin
  328.             Delete(TempText,CursorPos,1);
  329.             Insert(Ch,TempText,CursorPos);
  330.             If CursorPos < L then
  331.                CursorPos := Succ(CursorPos);
  332.         end;   {if insert}
  333.         Write_String;
  334.     end;   {sub proc Add_Char}
  335.  
  336.  
  337. begin                  {main Procedure Read_Line}
  338.     Check_Parameters;
  339.     R_Null := false;
  340.     FindCursor(Cursor_X,Cursor_Y,ScanTop,ScanBot);
  341.     If RTTT.Insert then
  342.        HalfCursor
  343.     else
  344.        OnCursor;
  345.     Write_String;
  346.     FirstCharPress := true;
  347.     Repeat
  348.          Ch := Getkey;
  349.          If Format in [2,3] then
  350.             Ch := upcase(Ch);
  351.          If Ch in RTTT.End_Chars then
  352.          begin
  353.             AllDone := True;
  354.             If Ch <> #027 then Text := TempText;
  355.          end
  356.          else
  357.          if Extended then
  358.          begin
  359.              Case Ch of
  360.              #131,              {mouseright}
  361.              CursorRight   :  begin
  362.                                   If (CursorPos < L)
  363.                                   and (CursorPos <= length(TempText)) then
  364.                                   begin
  365.                                       CursorPos := Succ(CursorPos);
  366.                                       MoveTheCursor;
  367.                                   end;
  368.                               end;
  369.              #130,               {mouseleft}
  370.              CursorLeft    :  begin
  371.                                   If CursorPos > 1 then
  372.                                   begin
  373.                                       CursorPos := Pred(CursorPos);
  374.                                       MoveTheCursor;
  375.                                   end;
  376.                               end;
  377.              HomeKey       :  begin
  378.                                   CursorPos := 1;
  379.                                   MoveTheCursor;
  380.                               end;
  381.              EndKey        :  begin
  382.                                   If CursorPos < L then
  383.                                   If length(TempText) < L then
  384.                                       CursorPos := length(TempText) + 1
  385.                                   else
  386.                                       CursorPos := L;
  387.                                   MoveTheCursor;
  388.                               end;
  389.             InsKey        :  If Format <> 3 then   {don't allow insert on Y/N!}
  390.                              begin
  391.                                  InsertMode := not InsertMode;
  392.                                  If InsertMode then
  393.                                     HalfCursor
  394.                                  else
  395.                                     OnCursor;
  396.                              end;
  397.             DelKey        :  Char_Del;
  398.             Zap           :  Erase_Field;
  399.             #132,
  400.             EscKey        :  If RTTT.AllowEsc then
  401.                                  Alldone := true
  402.                              else
  403.                                 Clang;
  404.             #133          :  begin
  405.                                  Alldone := true;
  406.                                  Text := TempText;
  407.                              end;
  408.             #128,#129     :;    {absorb stray mouse movement to avoid Clang'n}
  409.           else Clang;
  410.       end; {case}
  411.       end
  412.       else  {not extended}
  413.       begin
  414.           Case Ch of
  415.            BackSpace     :  Char_Backspace;
  416.            EnterKey      :  begin
  417.                                  Alldone := true;
  418.                                  Text := TempText;
  419.                             end;
  420.            #33 .. #42,                                 {! to *}
  421.            #44,#47,                                    {, /}
  422.            #58 .. #64,                                 {: to @}
  423.            #91 .. #96,                                 {[ to '}
  424.            #123 .. #126   :  If (Format in [1,2]) then {{ to ~}
  425.                              begin
  426.                                  If FirstCharPress and RTTT.EraseDefault then
  427.                                     Erase_Field;
  428.                                  Add_Char(Ch);
  429.                              end
  430.                              else
  431.                                  Clang;
  432.            #43, #45       : If (Format in [1,2])       { + - }
  433.                             or ( (CursorPos=1) and (Format in [5,6,7])) then
  434.                             begin
  435.                                 If FirstCharPress and RTTT.EraseDefault then
  436.                                     Erase_Field;
  437.                                 Add_Char(Ch);
  438.                             end
  439.                             else
  440.                                Clang;
  441.            #46            : If (Format in [1,2])       {.}
  442.                             or ( (Pos('.',TempText)=0) and (Format = 7)) then
  443.                             begin
  444.                                 If FirstCharPress and RTTT.EraseDefault then
  445.                                     Erase_Field;
  446.                                 Add_Char(Ch);
  447.                             end
  448.                             else
  449.                                Clang;
  450.            #48..#57       : If (Format in [1..2,5..8]) then {0 to 9}
  451.                             begin
  452.                                 If FirstCharPress and RTTT.EraseDefault then
  453.                                     Erase_Field;
  454.                                 Add_Char(Ch);
  455.                             end
  456.                             else
  457.                                Clang;
  458.            #32,                                              {space}
  459.            #65..#77,                                         {A to M}
  460.            #79..#88,                                         {O to X}
  461.            #90,                                              {Z}
  462.            #97..#255      : If (Format in [1,2,4]) then      {a to z}
  463.                             begin
  464.                                 If FirstCharPress and RTTT.EraseDefault then
  465.                                     Erase_Field;
  466.                                 Add_Char(Ch);
  467.                             end
  468.                             else
  469.                                Clang;
  470.            #78,#89        : If (Format in [1..4]) then        {N Y}
  471.                             begin
  472.                                 Add_Char(Ch);
  473.                                 If Format = 3 then
  474.                                 begin
  475.                                     Alldone := true;
  476.                                     Text := TempText;
  477.                                 end;
  478.                             end
  479.                             else
  480.                                Clang;
  481.  
  482.           end; {case}
  483.       end;
  484.       FirstCharPress := false;
  485.       Until Alldone;
  486.       R_Char := Ch;
  487.       If  RTTT.RightJustify
  488.       and (Format > 4) then
  489.       begin
  490.           Fastwrite(X,Y,attr(F,B),replicate(L,RTTT.Whitespace));
  491.           Fastwrite(X+L-Length(TempText),Y,attr(F,B),Text);
  492.       end
  493.       else
  494.         Fastwrite(X,Y,attr(F,B),FillWhiteSpace(Text));
  495.       GotoXY(Cursor_X,Cursor_Y);
  496.       SizeCursor(ScanTop,ScanBot);
  497. end;  {Proc Read_Line}
  498.  
  499. Procedure Display_Box_and_Prompt(var X1,Y: byte;
  500.                                  BoxType:byte;
  501.                                  Prompt: StrScreen;
  502.                                  L:byte);
  503. {ensures that the input will fit on the screen, then draws box and prompt}
  504. const
  505.    Upchar = '^';
  506.    DnChar = '_';
  507. var
  508.   P,
  509.   width:byte;
  510.   InBorder : byte;    {is title in box border - 0 no, 1 upper, 2 lower}
  511. begin
  512.     If not ( (Y-ord(BoxType > 0)) in [1..DisplayLines] ) then
  513.        Y := 2;
  514.     If (X1 < 1) then
  515.        X1 := 2;
  516.     P := length(Prompt);
  517.     If (P > 1) and (Boxtype > 0) then    {check and see if prompt is in box}
  518.     begin
  519.        If Prompt[1] = Upchar then
  520.        begin
  521.            delete(Prompt,1,1);
  522.            dec(P);
  523.            InBorder := 1;
  524.        end
  525.        else
  526.           If Prompt[1] = DnChar then
  527.           begin
  528.               delete(Prompt,1,1);
  529.               dec(P);
  530.               InBorder := 2;
  531.           end
  532.           else
  533.              InBorder := 0;
  534.     end
  535.     else
  536.        InBorder := 0;
  537.     If InBorder > 0 then                      {determine dimensions of box}
  538.     begin
  539.         If P > L then
  540.            width := succ(P)
  541.         else
  542.            width := succ(L);
  543.     end
  544.     else
  545.        width := succ(P+l);
  546.     If pred(X1 + width) > 80 then
  547.        X1 :=  succ(80 - width);
  548.     If BoxType > 0 then         {draw the box}
  549.        FBox(X1,pred(Y),X1+width,succ(Y),RTTT.BoxFCol,RTTT.BoxBCol,BoxType);
  550.     If P > 0 then               {Draw the prompt}
  551.         Case InBorder of
  552.         0 : If BoxType> 0 then
  553.                Fastwrite(succ(X1),Y,attr(RTTT.PFcol,RTTT.PBCol),Prompt) {left Justified in upper border}
  554.             else
  555.                Fastwrite(X1,Y,attr(RTTT.PFcol,RTTT.PBCol),Prompt);
  556.         1 : FastWrite(succ(X1),pred(Y),attr(RTTT.PFcol,RTTT.PBCol),Prompt);
  557.         2 : FastWrite(X1+width-P,succ(Y),attr(RTTT.PFcol,RTTT.PBCol),Prompt);   {right justified in lower border}
  558.         end;
  559.     If InBorder > 0 then        {return var X1 adjusted to position of input field}
  560.     begin
  561.        If Boxtype > 0 then
  562.           X1 := succ(X1);
  563.     end
  564.     else
  565.     begin
  566.        If Boxtype > 0 then
  567.           X1 := succ(X1) + p
  568.        else
  569.           X1 := X1 + P;
  570.     end;
  571. end;
  572. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  573.  
  574.  Procedure ReadLine(X,Y,L,F,B:byte;var Text: string;var Retcode:integer);
  575.  {compatibility module with TTT 4.0}
  576.  begin
  577.      Read_Line(X,Y,L,F,B,1,Text);
  578.      If R_Char = #027 then
  579.         RetCode := 1         {5.00a}
  580.      else
  581.         Retcode := 0;        {5.00a}
  582.  end; {of proc ReadLine}
  583.  
  584.  
  585. Procedure Read_String(X,Y,L:byte;
  586.                       Prompt:StrScreen;
  587.                       BoxType: byte;
  588.                       Var Txt:StrScreen);
  589. begin
  590.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  591.     Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,1,Txt);
  592. end;
  593.  
  594. Procedure Read_String_Upper(X,Y,L:byte;
  595.                             Prompt:StrScreen;
  596.                             BoxType: byte;
  597.                             Var Txt:StrScreen);
  598. begin
  599.     Txt :=  Upper(Txt);
  600.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  601.     Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,2,Txt);
  602. end;
  603.  
  604. Procedure Read_Password(X,Y,L:byte;
  605.                         Prompt:StrScreen;
  606.                         BoxType: byte;
  607.                         Var Txt:StrScreen);
  608. begin
  609.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  610.     Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,11,Txt);
  611. end;
  612.  
  613. Procedure Read_Alpha(X,Y,L:byte;
  614.                      Prompt:StrScreen;
  615.                      BoxType: byte;
  616.                      Var Txt:StrScreen);
  617. begin
  618.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  619.     Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,4,Txt);
  620. end;
  621.  
  622. Procedure Read_YN(X,Y:byte;
  623.                   Prompt:StrScreen;
  624.                   BoxType: byte;
  625.                   Var Yes:Boolean);
  626.  
  627. var
  628.   Global_Insert : boolean;
  629.   Txt : StrScreen;
  630. begin
  631.     If Yes then
  632.        Txt := 'Y'
  633.     else
  634.        Txt := 'N';
  635.     Global_Insert := RTTT.insert;
  636.     RTTT.Insert := false;            {force to overwrite mode}
  637.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,1);
  638.     Read_Line(X,Y,1,RTTT.FCol,RTTT.BCol,3,Txt);
  639.     RTTT.Insert := Global_Insert;    {reset back}
  640.     If Txt = 'Y' then
  641.        Yes := true
  642.     else
  643.        Yes := false;
  644. end;
  645.  
  646. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  647.  
  648. Procedure Invalid_Message(Y : byte; var CH : char);
  649. begin
  650.    Clang;
  651.    TempMessageCH(1,Y,RTTT.Msg_Fcol,RTTT.Msg_BCol,
  652.                PadCenter('Invalid number - press any key to resume',80,' '),CH);
  653. end;
  654.  
  655. Procedure OutOfRange_Message(Y : byte;MinS,MaxS : StrScreen;var CH:char);
  656. var S : StrScreen;
  657. begin
  658.    Clang;
  659.    S := 'Error value must be in the range '+MinS+' to '+MaxS+' - press any key to resume';
  660.    TempMessageCh(1,Y,RTTT.Msg_Fcol,RTTT.Msg_BCol,PadCenter(S,80,' '),CH);
  661. end;
  662.  
  663. Function MessageLine(Y : byte):byte;
  664. begin
  665.     If (RTTT.Msg_Line = 0) or (RTTT.Msg_Line > DisplayLines) then
  666.     begin
  667.         If Y < DisplayLines then    {set message Line}
  668.            MessageLine := succ(Y)
  669.         else
  670.            MessageLine := pred(Y);
  671.     end
  672.     else
  673.        MessageLine := RTTT.Msg_Line;
  674. end;
  675.  
  676. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  677.  
  678. Procedure Read_Byte(X,Y,L:byte; 
  679.                     Prompt:StrScreen;
  680.                     BoxType: byte;
  681.                     Var B : byte; 
  682.                     Min, Max : byte);
  683. var
  684.    Temp : byte;
  685.    Txt : StrScreen;
  686.    Valid : boolean;
  687.    Code : integer;
  688.    YT : byte;
  689.    CHB : char;
  690. begin
  691.     If Max = 0 then
  692.       Max := 255;
  693.     If Min >= Max then
  694.        Min := 0;
  695.     If (B < Min) or (B > Max) then
  696.         B := Min;
  697.     If ((B = 0) and RTTT.SuppressZero) then
  698.        Txt := ''
  699.     else
  700.        Txt := Int_To_Str(B);
  701.     Temp := B;
  702.     Valid := false;
  703.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  704.     YT := MessageLine(Y);
  705.     Repeat
  706.          Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,8,Txt);
  707.          If ((R_Char = #027) and RTTT.AllowEsc)
  708.          or ((Txt = '') and (RTTT.AllowNull)) then
  709.          begin
  710.              If Txt = '' then R_Null := true;
  711.              exit;
  712.          end
  713.          else
  714.          begin
  715.              val(Txt,Temp,code);
  716.              If code <> 0 then
  717.              begin
  718.                 Invalid_Message(YT,CHB);
  719.                 If ChB = #027 then
  720.                         Txt := Int_To_Str(B);
  721.              end
  722.              else
  723.              begin
  724.                  If (Temp < Min) 
  725.                  or (Temp > Max) 
  726.                  or ((length(Txt) > 2) and (Txt > '255')) then
  727.                  begin
  728.                     OutOfRange_Message(Yt,Int_To_Str(Min),Int_To_Str(Max),CHB);
  729.                     If ChB = #027 then
  730.                         Txt := Int_To_Str(B);
  731.                  end
  732.                  else
  733.                  begin
  734.                      B := temp;
  735.                      Valid := true;
  736.                  end;
  737.              end;
  738.          end;
  739.     Until Valid or ((R_Char = #027) and RTTT.AllowEsc);
  740. end;
  741.  
  742. Procedure Read_Word(X,Y,L:byte; 
  743.                     Prompt:StrScreen;
  744.                     BoxType: byte;
  745.                     Var W : word; 
  746.                     Min, Max : word);
  747. var
  748.    Temp : word;
  749.    Txt : StrScreen;
  750.    Valid : boolean;
  751.    Code : integer;
  752.    YT : byte;
  753.    ChW : char;
  754. begin
  755.     If Max = 0 then
  756.       Max := MaxWord;
  757.     If Min >= Max then
  758.        Min := MinWord;
  759.     If (W < Min) or (W > Max) then
  760.         W := Min;
  761.     If ((W = 0) and RTTT.SuppressZero) then
  762.        Txt := ''
  763.     else
  764.        Txt := Int_To_Str(W);
  765.     Temp := W;
  766.     Valid := false;
  767.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  768.     YT := MessageLine(Y);
  769.     Repeat
  770.          Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,8,Txt);
  771.          If ((R_Char = #027) and RTTT.AllowEsc)
  772.          or ((Txt = '') and (RTTT.AllowNull)) then
  773.          begin
  774.              If Txt = '' then R_Null := true;
  775.              exit;
  776.          end
  777.          else
  778.          begin
  779.              val(Txt,Temp,code);
  780.              If code <> 0 then
  781.              begin
  782.                 Invalid_Message(YT,ChW);
  783.                 If ChW = #027 then
  784.                         Txt := Int_To_Str(W);
  785.              end
  786.              else
  787.              begin
  788.                  If (Temp < Min) 
  789.                  or (Temp > Max) 
  790.                  or ((length(Txt) > 4) and (Txt > Int_To_Str(MaxWord))) then
  791.                  begin
  792.                     OutOfRange_Message(Yt,Int_To_Str(Min),Int_To_Str(Max),ChW);
  793.                     If ChW = #027 then
  794.                         Txt := Int_To_Str(W);
  795.                  end
  796.                  else
  797.                  begin
  798.                      W := temp;
  799.                      Valid := true;
  800.                  end;
  801.              end;
  802.          end;
  803.     Until Valid  or ((R_Char = #027) and RTTT.AllowEsc);
  804. end;
  805.  
  806.  
  807. Procedure Read_Int(X,Y,L:byte;
  808.                    Prompt:StrScreen;
  809.                    BoxType: byte;
  810.                    Var W : integer;
  811.                    Min, Max : integer);
  812. var
  813.    Temp : integer;
  814.    Txt : StrScreen;
  815.    Valid : boolean;
  816.    Code : integer;
  817.    YT : byte;
  818.    ChI : char;
  819. begin
  820.     If Max = 0 then
  821.       Max := MaxInt;
  822.     If Min >= Max then
  823.        Min := MinInt;
  824.     If (W < Min) or (W > Max) then
  825.         W := Min;
  826.     If ((W = 0) and RTTT.SuppressZero) then
  827.        Txt := ''
  828.     else
  829.        Txt := Int_To_Str(W);
  830.     Temp := W;
  831.     Valid := false;
  832.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  833.     YT := MessageLine(Y);
  834.     Repeat
  835.          Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,5,Txt);
  836.          If ((R_Char = #027) and RTTT.AllowEsc)
  837.          or ((Txt = '') and (RTTT.AllowNull)) then
  838.          begin
  839.              If Txt = '' then R_Null := true;
  840.              exit;
  841.          end
  842.          else
  843.          begin
  844.              val(Txt,Temp,code);
  845.              If code <> 0 then
  846.              begin
  847.                 Invalid_Message(YT,ChI);
  848.                 If ChI = #027 then
  849.                    Txt := Int_to_Str(W);
  850.  
  851.              end
  852.              else
  853.              begin
  854.                  If (Temp < Min) or (Temp > Max) then
  855.                  begin
  856.                     OutOfRange_Message(Yt,Int_To_Str(Min),Int_To_Str(Max),ChI);
  857.                     If ChI = #027 then
  858.                        Txt := Int_to_Str(W);
  859.                  end
  860.                  else
  861.                  begin
  862.                      W := temp;
  863.                      Valid := true;
  864.                  end;
  865.             end;
  866.         end;
  867.     Until Valid  or ((R_Char = #027) and RTTT.AllowEsc);
  868. end;
  869.  
  870. Procedure Read_LongInt(X,Y,L:byte;
  871.                    Prompt:StrScreen;
  872.                    BoxType: byte;
  873.                    Var W : longint;
  874.                    Min, Max : longint);
  875. var
  876.    Temp : longint;
  877.    Txt : StrScreen;
  878.    Valid : boolean;
  879.    Code : integer;
  880.    YT : byte;
  881.    ChI : char;
  882. begin
  883.     If Max = 0 then
  884.       Max := MaxLongInt;
  885.     If Min >= Max then
  886.        Min := MinLongInt;
  887.     If (W < Min) or (W > Max) then
  888.         W := Min;
  889.     If ((W = 0) and RTTT.SuppressZero) then
  890.        Txt := ''
  891.     else
  892.        Txt := Int_To_Str(W);
  893.     Temp := W;
  894.     Valid := false;
  895.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);
  896.     YT := MessageLine(Y);
  897.     Repeat
  898.          Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,5,Txt);
  899.          If ((R_Char = #027) and RTTT.AllowEsc)
  900.          or ((Txt = '') and (RTTT.AllowNull)) then
  901.          begin
  902.              If Txt = '' then R_Null := true;
  903.              exit;
  904.          end
  905.          else
  906.          begin
  907.              val(Txt,Temp,code);
  908.              If code <> 0 then
  909.              begin
  910.                 Invalid_Message(YT,ChI);
  911.                 If ChI = #027 then
  912.                    Txt := Int_to_Str(W);
  913.              end
  914.              else
  915.              begin
  916.                  If (Temp < Min) or (Temp > Max) then
  917.                  begin
  918.                     OutOfRange_Message(Yt,Int_To_Str(Min),Int_To_Str(Max),ChI);
  919.                     If ChI = #027 then
  920.                        Txt := Int_to_Str(W);
  921.                  end
  922.                  else
  923.                  begin
  924.                      W := temp;
  925.                      Valid := true;
  926.                  end;
  927.             end;
  928.         end;
  929.     Until Valid  or ((R_Char = #027) and RTTT.AllowEsc);
  930. end;
  931.  
  932. Procedure Read_Real(X,Y,L:byte;
  933.                     Prompt:StrScreen;
  934.                     BoxType: byte;
  935.                     Var W : real; 
  936.                     Min, Max : real);
  937. var
  938.    Temp : Real;
  939.    Txt : StrScreen;
  940.    Valid : boolean;
  941.    Code : integer;
  942.    YT : byte;
  943.    ChR : char;
  944. begin
  945.     If Max = 0 then
  946.       Max := 99999999;
  947.     If Min >= Max then
  948.        Min := -99999999;
  949.     If (W < Min) or (W > Max) then
  950.         W := Min;
  951.     If Min < 0 then    {add room for - sign}
  952.        Inc(L);
  953.     If ((W = 0.0) and RTTT.SuppressZero) then
  954.        Txt := ''
  955.     else
  956.        Txt := Real_To_Str(W,RTTT.RealDP);
  957.     Temp := W;
  958.     Valid := false;
  959.     Display_Box_and_Prompt(X,Y,Boxtype,Prompt,L);      {5.00b}
  960.     YT := MessageLine(Y);
  961.     Repeat
  962.          Read_Line(X,Y,L,RTTT.FCol,RTTT.BCol,7,Txt);
  963.          If ((R_Char = #027) and RTTT.AllowEsc)
  964.          or ((Txt = '') and (RTTT.AllowNull)) then
  965.          begin
  966.              If Txt = '' then R_Null := true;
  967.              exit;
  968.          end
  969.          else
  970.          begin
  971.              val(Txt,Temp,code);
  972.              If code <> 0 then
  973.              begin
  974.                 Invalid_Message(YT,ChR);
  975.                 If ChR = #027 then
  976.                    Txt := Real_to_Str(W,RTTT.RealDP);
  977.              end
  978.              else
  979.              begin
  980.                  If (Temp < Min) or (Temp > Max) then
  981.                  begin
  982.                     OutOfRange_Message(Yt,Real_To_Str(Min,RTTT.RealDP),Real_To_Str(Max,RTTT.RealDP),ChR);
  983.                     If ChR = #027 then
  984.                        Txt := Real_to_Str(W,RTTT.RealDP);
  985.                  end
  986.                  else
  987.                  begin
  988.                      W := temp;
  989.                      Valid := true;
  990.                  end;
  991.             end;
  992.         end;
  993.     Until Valid  or ((R_Char = #027) and RTTT.AllowEsc);
  994. end;
  995.   
  996. Procedure Read_Select(X,Y:byte;Pmt,Txt:StrScreen;var Choice:byte);
  997. Const
  998.      UpChar:string[1] = '^';
  999.      JoinChar:string[1] = '_';
  1000. var
  1001.   W : byte;
  1002.   I : integer;
  1003.   Horiz : boolean;
  1004.      Function Replace_JoinChar(Str:string): string;
  1005.      {}
  1006.      var I : integer;
  1007.      begin
  1008.          For I := 1 to length(Str) do
  1009.              If Str[I] = JoinChar then
  1010.                 Str[I] := ' ';
  1011.          Replace_JoinChar := Str;
  1012.      end; {of func Replace_JoinChar}
  1013.  
  1014.      Procedure HiLightWord(W:byte;Hi:boolean);
  1015.      var Col : byte;
  1016.      begin
  1017.          If Hi then
  1018.             Col := attr(RTTT.HiFCol,RTTT.HiBcol)
  1019.          else
  1020.             Col := attr(RTTT.LoFcol,RTTT.LoBcol);
  1021.          If Horiz then
  1022.              Fastwrite(pred(X)+PosWord(W,Txt),Y,Col,Replace_JoinChar(ExtractWords(W,1,Txt)))
  1023.          else
  1024.              Fastwrite(X,pred(Y)+W,Col,Replace_JoinChar(ExtractWords(W,1,Txt)));
  1025.          If Hi then
  1026.          begin
  1027.             If Horiz then
  1028.                GotoXY(pred(X)+PosWord(W,Txt),Y)
  1029.             else
  1030.                GotoXY(X,Pred(Y)+W);
  1031.          end;
  1032.      end;
  1033.  
  1034.      Procedure Process_Keys;
  1035.      var
  1036.        ChP : char;
  1037.        Finished : boolean;
  1038.      begin
  1039.          Finished := false;
  1040.          Repeat
  1041.               ChP := getKey;
  1042.               If ChP in RTTT.End_Chars then
  1043.                   Finished := True
  1044.               else
  1045.               Case upcase(ChP) of
  1046.               #132,
  1047.               EscKey      : If RTTT.AllowEsc then
  1048.                                 Finished := true;
  1049.               ' ',#9,                                 {tab}
  1050.               CursorDown,
  1051.               CursorRight : begin
  1052.                                 HiLightWord(Choice,false);
  1053.                                 If Choice < W then
  1054.                                    Inc(Choice)
  1055.                                 else
  1056.                                    Choice := 1;
  1057.                                 HiLightWord(Choice,true);
  1058.                             end;
  1059.               #143,                     {Shift tab}
  1060.               CursorUp,
  1061.               CursorLeft  : begin
  1062.                                 HiLightWord(Choice,false);
  1063.                                 If Choice > 1 then
  1064.                                    Dec(Choice)
  1065.                                 else
  1066.                                    Choice := W;
  1067.                                 HiLightWord(Choice,true);
  1068.                             end;
  1069.               #131        : If (Choice < W) and Horiz then    {mouse right}
  1070.                             begin
  1071.                                 HiLightWord(Choice,false);
  1072.                                 Inc(Choice);
  1073.                                 HiLightWord(Choice,true);
  1074.                             end;
  1075.               #130        : If (Choice > 1) and Horiz then    {mouse left}
  1076.                             begin
  1077.                                 HiLightWord(Choice,false);
  1078.                                 Dec(Choice);
  1079.                                 HiLightWord(Choice,true);
  1080.                             end;
  1081.               #129        : If (Choice < W) and (Horiz = false) then    {mouse down}
  1082.                             begin
  1083.                                 HiLightWord(Choice,false);
  1084.                                 Inc(Choice);
  1085.                                 HiLightWord(Choice,true);
  1086.                             end;
  1087.               #128        : If (Choice > 1) and (Horiz = false) then    {mouse up}
  1088.                             begin
  1089.                                 HiLightWord(Choice,false);
  1090.                                 Dec(Choice);
  1091.                                 HiLightWord(Choice,true);
  1092.                             end;
  1093.  
  1094.               end; {case}
  1095.          until Finished;
  1096.          R_Char := ChP;
  1097.      end;
  1098.  
  1099. begin
  1100.     If Txt[1] = UpChar then
  1101.     begin
  1102.         Horiz := False;
  1103.         Delete(Txt,1,1);
  1104.     end
  1105.     else
  1106.        Horiz := true;
  1107.     W := Wordcnt(Txt);
  1108.     If W < 2 then exit;              {only show choices if there are two or more}
  1109.     FindCursor(Cursor_X,Cursor_Y,ScanTop,ScanBot);   {record cursor settings}
  1110.     If (Choice > W) or (Choice < 1) then               {check that W is sensible}
  1111.        Choice := 1;
  1112.     If Pmt <> '' then
  1113.     begin
  1114.         Fastwrite(X,Y,attr(RTTT.PFcol,RTTT.PBCol),Pmt);
  1115.         X := X+length(Pmt);
  1116.     end;
  1117.     For I := 1 to W do
  1118.         HiLightWord(I,False);
  1119.     OnCursor;
  1120.     HiLightWord(Choice,True);
  1121.     Process_keys;
  1122.     GotoXY(Cursor_X,Cursor_Y);           {reset cursor}
  1123.     SizeCursor(ScanTop,ScanBot);
  1124. end;  {proc Read_Select}
  1125.  
  1126. begin
  1127.    Default_Settings;
  1128. end.
  1129.